perm filename XMARK.SAI[X,ALS] blob
sn#087637 filedate 1974-02-20 generic text, type T, neo UTF8
00010 BEGIN "MARKX"
00020 DEFINE ⊂="COMMENT"; ⊂ NOV.26,1973;
00030 ⊂ This program is a very simple pitch marking routine to be used to
00040 suppliment Neil's routine in certain cases;
00050 DEFINE ⊃="⊂";
00060 DEFINE CR="'15",LF="'12",CRLF="CR&LF",TB="'11";
00070 LABEL STARTP,STOPP,TOFORM;
00080 DEFINE \=" "; ⊂ DEFINE \="SAFE"; ⊂ Alternarte definitions;
00090 INTEGER SUM,SUMM,SUMP,MAX,MIN,
00100 SUMREF,SUMSAV,SUMMIN,SUMMAX,SUMOLD;
00110 INTEGER MAXOLD,MINOLD,MARGIN,PER,PERMIN,PERMAX;
00120 INTEGER QOLD,QSAVE,QREF,QOLD2;
00130 INTEGER ZEROC,ZEROF,DX;
00140 \ INTERNAL INTEGER ARRAY FVAL,NVAL[0:8];
00150 INTEGER FX;
00160 INTEGER I,J,K,L,P,PP,Q,QQ,QNEG,QPOS,R,DK,DDK,DDDK,DVAL,DDVAL,DDDVAL,ALPHA,
00170 POINTF,POINTX,STATE,DELTA,DELTN,VAL,CHAN1,EOF,POINTT,POINTV;
00180 INTERNAL INTEGER M,N,PERIOD;
00190 INTEGER PT0,PT1,PT2,X0,X1,Y0,Y1,X2,Y2,
00200 PTCNT,PICK,JP,JPP,JPX,OPT,OPT1,SHUFCT;
00210 INTEGER II,JJ,KK,NN,SEGC,BRK,EOFA,EOFT,EOFTF,READ3,LFX,PITX,PITY,
00220 SEGTOT,SEGIN,KKT,NNT,ITT,JTT,KTT;
00230 BOOLEAN ER;
00240 INTEGER CHAN3;
00250 INTERNAL INTEGER CHAN5;
00260 \ INTEGER ARRAY BUF,BUFTT[0:511];
00270 \ INTEGER ARRAY BUFT[0:1023];
00280 STRING FILEN,FILEF,READ,READ1,READT,
00290 READTT,FILEO,READ2,FILEQ,TFILE,FILLST,FILEP;
00300
00310 INTEGER ARRAY QRES,SUMRES,SPAN[0:7];
00320 INTEGER QX,XXP,XXM,GOOD,XING;
00330
00340
00350 PROCEDURE OUTALL(STRING S);
00360 BEGIN
00370 STRING SS; INTEGER J;
00380 SETBREAK(18,0,NULL,"OSN");
00390 SS←SCAN(S,18,J);
00400 OUTSTR(SS);
00410 END;
00420
00430 PROCEDURE DATAIN;
00440 BEGIN
00450 INTEGER J;
00460 FOR J←0 STEP 1 UNTIL 511 DO BUF[J]←0;
00470 ⊂ IF EOF=0 THEN OUTSTR("BUF") ELSE OUTSTR(" EOF ");
00480 IF EOF=0 THEN ARRYIN(CHAN1,BUF[0],512) ELSE OUTSTR("Out of data"&crlf);
00490 ⊂ IF EOF=0 THEN OUTSTR(" New BUF ") ELSE OUTSTR(" EOF ");
00500 POINTX←POINT(12,BUF[0],-1);
00510 SEGC←II←II+12; JJ←II+11;
00520 END;
00530
00540
00550
00560
00570 PROCEDURE DATOUT;
00580 BEGIN "DATOUT"
00590 INTEGER I,J;
00600
00610 ARRYOUT(CHAN5,BUFT[0],512);
00620 FOR I←0 STEP 1 UNTIL 1023 DO BUFT[I]←0;
00630 PITX←0;
00640 END "DATOUT";
00650
00660
00670
00680
00690 PROCEDURE PEEK;
00700 BEGIN
00710
00720 OUTSTR(CRLF&"Q'S "&CVS(QREF)&" "&CVS(QSAVE)&" "&CVS(QOLD)&TB&" P="&CVS(P)&
00730 TB&"SUM'S "&CVS(SUMREF)&" "&CVS(SUMSAV)&" "&CVS(SUMOLD)&
00740 TB&"PERIOD="&CVS(PERIOD)&" "&CVS(PER)&CRLF);
00750 END;
00760
00770 PROCEDURE SPOR;
00780 BEGIN
00790 OUTSTR(CVS(STATE)&" ");
00800 END;
00810
00820 PROCEDURE PITCH;
00830 BEGIN "PITCH"
00840
00850 CASE STATE OF BEGIN
00860
00870 ⊂ State 0 from 2 on - ;
00880 IF VAL>0 THEN BEGIN
00890 STATE←2; QOLD←QQ; SUMP←MAX←VAL; XING←XING+1;
00900 ⊃ SPOR;
00910 END;
00920
00930 ⊂ STATE 1 from 5 on + ;
00940 IF VAL<0 THEN BEGIN
00950 IF XXP<2 THEN BEGIN
00960 STATE←5; SUM←SUM+SUMP-VAL;
00970 ⊃ SPOR;
00980 IF MAXOLD>MAX THEN MAX←MAXOLD;
00990 END;
01000 END ELSE BEGIN
01010 SUMP←SUMP+VAL;
01020 IF VAL>MAX THEN MAX←VAL;
01030 IF SUMP>DELTA THEN BEGIN
01040 STATE←2; SUM←0;
01050 ⊃ SPOR;
01060 ⊂ PEEK;
01070 ⊂ Decision;
01080 P←0;
01090 IF XING≥15 THEN P←0 ELSE
01100 IF (GOOD<2)∧(XING<5)∧(SUMOLD>SUMSAV)
01110 THEN P←1 ELSE
01120 IF (SUMREF=SUMSAV)∧(PER>PERIOD*3%4)∧(QOLD-QSAVE>PERIOD*3%4)
01130 THEN P←2 ELSE
01140 IF (SUMOLD<SUMSAV) THEN SUMSAV←SUMOLD ELSE
01150 IF (SUMOLD>SUMSAV*4%3)∧(PER>PERIOD*7%8)∧(SUMOLD>SUMREF%2)
01160 THEN P←3 ELSE
01170 IF (SUMOLD>SUMSAV*5%4)∧(PER>PERIOD*9%10)∧(SUMOLD>SUMMIN)
01180 THEN P←4 ELSE
01190 IF (SUMREF≤SUMMIN)∧(SUMOLD>SUMREF)
01200 THEN P←5 ELSE
01210 IF (SUMOLD>SUMREF*5%4)∧(PER>PERIOD*5%8)
01220 THEN P←6; ⊂ To get in step;
01230 IF (PER>PERIOD*3%2)∧(P=0)∧(XING≤15) THEN BEGIN
01240 K←0;
01250 FOR I←0 STEP 1 UNTIL 7 DO
01260 IF SUMRES[I]>K THEN BEGIN K←SUMRES[I]; QX←I; END;
01270 IF K>2000 THEN BEGIN
01280 QSAVE←QRES[QX]; SUMOLD←SUMRES[QX]; P←7;
01290 END;
01300 END;
01310 ⊃ OUTSTR(CRLF&"Q"&CVS(QSAVE)&" S"&CVS(SUMOLD)&" A"&CVS(MAXOLD-MINOLD)&" ");
01320 ⊃ IF P≠0 THEN OUTSTR("P"&CVS(P)&TB);
01330
01340 IF ((QRES[QX]-QREF)>(PERIOD%2))∧(P=0)∧(QX<7) THEN BEGIN
01350 ⊃ OUTSTR(CRLF&"QX="&CVS(QX)&TB&CVS(QRES[QX])&TB&CVS(SUMRES[QX])&TB&CVS(SPAN[QX]));
01360 QX←QX+1; END;
01370 IF P>0 THEN BEGIN
01380 GOOD←GOOD+1; XING←0;
01382 IF PITX≥2 THEN WHILE (BUFT[PITX-2] LSH -15)≥QSAVE DO BEGIN
01384 IF PITX≥2 THEN PITX←PITX-2 ELSE DONE;; ⊂ QREF←QREF-PERIOD; END;
01390 ⊂ Record mark;
01400 BUFT[PITX]←(QSAVE LSH 15)+(SUMOLD LAND '77770)+(P LAND '7);
01410 BUFT[PITX+1]←(SPAN[QX] LSH 23)+(PERIOD LSH 10)+PER;
01420 PITX←PITX+2; IF PITX≥512 THEN DATOUT;
01430
01440 ⊂ PEEK;
01450 SUMREF←SUMOLD; ⊂ PER←QSAVE-QREF; QREF←QSAVE;
01460 IF (PER>PERMIN)∧(PER<PERMAX) THEN PERIOD←(2*PERIOD+PER)%3;
01470 FOR I←0 STEP 1 UNTIL 7 DO SUMRES[I]←SPAN[I]←0;
01480 QX←0;
01490 JPP←0;
01500 END;
01510 END;
01520 END;
01530
01540 ⊂ STATE 2 from 0 on + from 1 on alpha with decision;
01550 IF VAL<ALPHA THEN BEGIN
01560 QOLD←QQ-1;
01570 IF VAL<0 THEN BEGIN STATE←0; ⊃ SPOR; END;
01580 END ELSE BEGIN
01590 SUMP←SUMP+VAL; IF VAL>MAX THEN MAX←VAL;
01600 IF SUMP>DELTA THEN BEGIN
01610 XXM←0;
01620 STATE←3; QRES[QX]←QSAVE←QOLD; SUMSAV←SUMOLD;
01630 ⊃ SPOR;
01640 END;
01650 END;
01660
01670 ⊂ STATE 3 from 4 on + from 2 on delta;
01680 IF VAL<0 THEN BEGIN
01690 XXM←XXM+1;
01700 STATE←4; SUMM←MIN←VAL; QNEG←QQ;
01710 ⊃ SPOR;
01720 END ELSE BEGIN
01730 SUMP←SUMP+VAL; IF VAL>MAX THEN MAX←VAL;
01740 END;
01750
01760 ⊂ STATE 4 from 3 on - ;
01770 IF VAL>0 THEN BEGIN
01780 IF XXM<3 THEN BEGIN
01790 STATE←3; SUMP←SUMP+VAL-SUMM;
01800 ⊃ SPOR;
01810 END;
01820 END ELSE BEGIN
01830 SUMM←SUMM+VAL; IF VAL<MIN THEN MIN←VAL;
01840 ⊂ IF SUMM<DELTN THEN BEGIN ;
01850 IF (XXM≥3)∨((SUMM<DELTN)∧((QQ-QNEG)>3)) THEN BEGIN
01860 STATE←5; SUMRES[QX]←SUM←SUMP-SUMM; SUMP←SUMM←0;
01870 XXP←0;
01880 ⊃ SPOR;
01890 END;
01900 END;
01910
01920 ⊂ STATE 5 from 2 on - from 4 on DELTN;
01930 IF VAL>0 THEN BEGIN
01940 STATE←1;
01950 XXP←XXP+1; XING←XING+1;
01960 ⊃ SPOR;
01970 ⊂ Prepare for decision;
01980 MAXOLD←MAX; MINOLD←MIN; SUMRES[QX]←SUMOLD←SUM;
01990 SPAN[QX]←MAX-MIN;
02000 SUMP←MAX←VAL; ⊂ QSAVE←QOLD; QOLD←QQ;
02010 PER←QSAVE-QREF;
02020 END ELSE BEGIN
02030 SUM←SUM-VAL; IF VAL<MIN THEN MIN←VAL;
02040 END;
02050 END;
02060
02070
02080
02090 IF ((QQ-QREF)>(PERIOD*7%4))∧(P=0) THEN BEGIN
02100 K←0;
02110 FOR I←0 STEP 1 UNTIL 7 DO
02120 IF (SUMRES[I]>K)∧(QRES[I]>(QREF+PERIOD*3%4)) THEN BEGIN K←SUMRES[I];QX←I; END;
02130 IF (K>2000)∧(XING<15) THEN BEGIN
02140 QREF←QSAVE←QRES[QX]; SUMREF←SUMOLD←SUMRES[QX]; P←7;
02150 BUFT[PITX]←(QSAVE LSH 15)+(SUMOLD LAND '77770)+(P LAND '7);
02160 BUFT[PITX+1]←(SPAN[QX] LSH 23)+(PERIOD LSH 10)+PER;
02180 ⊃ OUTSTR(CRLF&"Q"&CVS(QSAVE)&" S"&CVS(SUMOLD)&" A"&CVS(SPAN[QX])&" ");
02190 ⊃ OUTSTR("*P"&CVS(P)&TB);
02200 FOR I←0 STEP 1 UNTIL 7 DO BEGIN "SLIDE"
02210 K←I+QX+1;
02220 IF K≤7 THEN BEGIN
02230 QRES[I]←QRES[K]; SUMRES[I]←SUMRES[K]; SPAN[I]←SPAN[K];
02240 END ELSE SUMRES[I]←SPAN[I]←0;
02250 IF SUMRES[I]=0 THEN DONE "SLIDE";
02260 END;
02270 QX←I;
02280 END ELSE BEGIN
02290 QREF←QREF+PERIOD; GOOD←0;
02300 BUFT[PITX]←QREF LSH 15; PER←PERIOD;
02310 ⊃ OUTSTR(CRLF&"Q"&CVS(QREF)&" ***"&TB);
02320 END;
02325 PITX←PITX+2; IF PITX≥512 THEN DATOUT;
02330 XING←0;
02340 ⊂ PEEK;
02350 ⊃ SPOR;
02360 END;
02370
02380 QQ←QQ+1; P←0;
02390
02400 END "PITCH";
02410
00010 FILEN←"HI20.001[DAT,NJM]";
00020 FILEO←"SEG1.ASP[SYN,ALS]";
00030 PERIOD←180; PERMAX←260; PERMIN←100; MARGIN←50; DELTA←200; DELTN←-100; QQ←0;
00040 SUMMIN←200; ALPHA←100;
00050
00060 STDBRK(1);
00070 SETBREAK(14,"∃",NULL,"INS");
00080 SETBREAK(15,'11&'12&'14&'15&'40,NULL,"INS");
00090 SETBREAK(16,'56,NULL,"INA");
00100 SETBREAK(17,'12,'15,"INS");
00110
00120 CHAN1←1;CHAN3←3; CHAN5←5;
00130 OUTSTR("This program generates a file of pitch markers similar to "&
00140 "the .P files"&CRLF&" but with extension of .ASP."&CRLF);
00150 OUTSTR("At present this program takes acoustic data from [CMP,VIN],"&
00160 CRLF&TB&CRLF&LF);
00170
00180
00190 STARTP:
00200
00210 OUTSTR(CRLF&"Type number of file to start (CR only for 1) ");
00220 IF (READ←INCHWL)="" THEN PP←1 ELSE PP←CVD(READ);
00230
00240 ⊂ Begin FILEREAD;
00250 FOR PP←PP STEP 1 UNTIL 26 DO BEGIN "FILEREAD"
00260 CLOSE(CHAN1); OPEN(CHAN1,"DSK",'10,2,0,0,0,EOF);
00270 SETFORMAT(-3,0); FILEQ←CVS(PP);
00280 FILEN←FILEN[1 TO 5]&FILEQ&"[DAT,NJM]";
00290 LOOKUP(CHAN1,FILEN,ER); TFILE←FILEN;
00300 WHILE ER DO BEGIN
00310 IF PP>1 THEN BEGIN OUTSTR("Out of data, will terminate."&CRLF);
00320 GOTO STOPP; END;
00330 OUTSTR(CRLF&"Can not find file "&TFILE&" File= ");
00340 LOOKUP(CHAN1,TFILE←INCHWL,ER); END;
00350 J←K←L←STATE←VAL←0; R←-1;
00360 SETFORMAT(1,0); FILEQ←CVS(PP); JP←10000; R←-1; CLRBUF;
00370
00380 FILEP←FILEO[1 TO 3]&FILEQ&".ASP[SYN,ALS]";
00390 CLOSE(CHAN5); OPEN(CHAN5,"DSK",'14,0,2,0,0,0);
00400 ENTER(CHAN5,FILEP,0);
00410 OUTSTR("File "&FILEP&" has been opened"&CRLF);
00420
00430 PITX←0;
00440 SUMREF←SUMOLD←SUMSAV←SUMMIN;
00450 WHILE EOF=0 DO BEGIN
00460 DATAIN;
00470 FOR J←0 STEP 1 UNTIL 1535 DO BEGIN
00480 VAL←ILDB(POINTX); IF VAL>2047 THEN VAL←VAL-4096;
00490 PITCH; END;
00500 END;
00510
00520
00010 CLOSE(CHAN1); CLOSE(CHAN3);
00020 DATOUT; CLOSE(CHAN5);
00030 IF JP<0 THEN DONE;
00040 END "FILEREAD";
00050
00060 OUTSTR("Data are exhausted"&CRLF&LF);
00070 STOPP: PTOCHW(0,'10103); PTOCHW(0,'10120);
00080 CLOSE(CHAN1);CLOSE(CHAN3);
00090 CLOSE(CHAN5);
00100
00110 END "MARKX";
00120